home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / xscm.lha / xscm / oltest.scm < prev    next >
Encoding:
Text File  |  1992-08-29  |  3.7 KB  |  146 lines
  1. (require 'format)
  2. (load "x11")
  3. (load "xt")
  4. (load "ol")
  5. (load "olsubs")
  6. (load "xevent")
  7.  
  8. (define (say x) (display x) (newline) (force-output))
  9.  
  10. (define (go)
  11.   (xt:realize-widget top-level)
  12.   (xt:main-loop))
  13.  
  14. (define top-level (ol:initialize "Test" "test"))
  15.  
  16. (define control-pane
  17.   (xt:create-managed-widget
  18.    "control pane" ol:control-area top-level
  19.    xt:n-h-space 20))
  20.  
  21. (define (event-demo)
  22.   (let ((stub-widget
  23.      (xt:create-managed-widget
  24.       "stub" ol:stub control-pane
  25.       xt:n-height 100
  26.       xt:n-width 200))
  27.     (msg-widget
  28.      (xt:create-managed-widget
  29.       "text" ol:static-text control-pane)))
  30.     (xt:add-event-handler
  31.      stub-widget x:leave-window-mask 0
  32.      (lambda args
  33.        (display "leaveWindow: ")
  34.        (display args)
  35.        (newline)))
  36.     (xt:add-event-handler
  37.      stub-widget x:pointer-motion-mask 0
  38.      (lambda args
  39.        (display "pointerMotion: ")
  40.        (display args)
  41.        (newline)))))
  42.  
  43. (define (rubbertile-demo)
  44.   (let ((base
  45.      (xt:create-managed-widget
  46.       "base"
  47.       ol:rubber-tile
  48.       control-pane)))
  49.     (do ((i 0 (1+ i)))
  50.         ((= i 3))
  51.         (let* ((rt (xt:create-managed-widget
  52.             (format #f "Tile ~A" i)
  53.             ol:rubber-tile base
  54.             xt:n-orientation ol:horizontal)))
  55.             (do ((j 0 (1+ j)))
  56.           ((= j 3))
  57.         (xt:create-managed-widget
  58.          (format #f "Button ~A" (+ j (* i 3)))
  59.          ol:rect-button rt))))
  60.     #t))
  61.  
  62. (define (menu-demo)
  63.   (let* ((st (xt:create-managed-widget
  64.           "st" ol:static-text control-pane
  65.                 xt:n-string "Press MENU here"))
  66.      (menu (xt:create-popup-shell
  67.                "popup" ol:menu-shell st
  68.         "pushpin" ol:out))
  69.      (menu-pane (xt:get-value menu xt:n-menu-pane xt:widget)))
  70.     (make-button "New" menu-pane (lambda (w) (say "New")))
  71.     (make-button "Open" menu-pane (lambda (w) (say "Open")))
  72.     (make-button "Save" menu-pane (lambda (w) (say "Save")))
  73.     (make-button "Print" menu-pane (lambda (w) (say "Print")))))
  74.     
  75. (define (textfield-demo)
  76.   (for-each
  77.    (lambda (x)
  78.      (let* ((name (car x))
  79.         (text (cadr x))
  80.         (label (xt:create-managed-widget
  81.             name ol:static-text control-pane
  82.             xt:n-string name
  83.             xt:n-width 70
  84.             xt:n-gravity "east"))
  85.         (field (xt:create-managed-widget
  86.             name ol:text-field control-pane
  87.             xt:n-string text)))
  88.        (xt:add-callback
  89.     field "verification"
  90.     (lambda (w) (say "Yokes!")))))
  91.    '(("MAKE:" "Acme") ("MODEL:" "Deluxe") ("SERIAL NO." "")))
  92.   (xt:set-values control-pane
  93.          xt:n-layout-type ol:fixedcols
  94.          "measure" 2
  95.          "charsVisible" 10))
  96.  
  97. (define (footerpanel-demo)
  98.   (let* ((footer-panel
  99.       (xt:create-managed-widget
  100.        "footerpanel" ol:footer-panel control-pane))
  101.          (control-area
  102.       (xt:create-managed-widget
  103.             "control" ol:control-area footer-panel))
  104.      (form
  105.       (xt:create-managed-widget
  106.        "form" ol:form footer-panel))
  107.      (status
  108.       (xt:create-managed-widget
  109.        "status" ol:oblong-button control-area))
  110.      (mode
  111.       (xt:create-managed-widget
  112.        "mode" ol:oblong-button control-area))
  113.      (st
  114.       (xt:create-managed-widget
  115.        "st" ol:static-text form
  116.        xt:n-x-vary-offset #t
  117.        xt:n-y-vary-offset #t))
  118.      (mo
  119.       (xt:create-managed-widget
  120.        "mo" ol:static-text form
  121.        xt:n-x-vary-offset #t
  122.        xt:n-y-vary-offset #t
  123.        xt:n-x-attach-right #t)))
  124.     (xt:add-callback
  125.      status xt:n-select
  126.      (let* ((msglist '("Status 1" "Status 2" "Status 3"))
  127.         (msg msglist))
  128.        (lambda (w)
  129.      (if (null? msg)
  130.          (set! msg msglist))
  131.      (xt:set-values st xt:n-string (car msg))
  132.      (set! msg (cdr msg)))))
  133.     (xt:add-callback
  134.      mode xt:n-select
  135.      (let* ((msglist '("Mode 1" "Mode 2" "Mode 3"))
  136.         (msg msglist))
  137.        (lambda (w)
  138.      (if (null? msg)
  139.          (set! msg msglist))
  140.      (xt:set-values mo xt:n-string (car msg))
  141.      (set! msg (cdr msg)))))))
  142.                 
  143.  
  144. ;(xt:realize-widget top-level)
  145. ;(xt:main-loop)
  146.